home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / NEWWIN.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  5.5 KB  |  117 lines
  1. ; NEWWIN.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        New-Window for interactively creation of windows    *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: TI        Date: 1988                *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;* - 09 Jan 92: Allow NO-DISPLAY being given without minimal size (mv)    *
  19. ;*                                    *
  20. ;*                    ``In nomine omnipotentii dei''    *
  21. ;************************************************************************
  22.  
  23. ; NEW-WINDOW - new version for 3.02
  24. ; NEW-WINDOW creates a window interactively.  The cursor can be moved
  25. ; around to mark the upper left hand and lower right hand corners of the
  26. ; window.  The window port object is returned.
  27. ;
  28. ; This function demonstrates how to create a non-destructive cursor
  29. ; in PC Scheme by using a popup window of size 1x1.
  30. ;
  31. ; Example: (new-window "A Window") -> port object
  32. ;
  33. ; Create a new window using the cursor keys and return the port object.
  34. ; The cursor keys position the corner markers, return accepts the
  35. ; marker's position, and any other key exits with no change.
  36. ; "minrows" and "mincols" say that the window will be at least that big.
  37. ; The window is displayed immediately unless the symbol NO-DISPLAY is used.
  38. ; The new window always has a border.
  39. ; syntax:  (NEW-WINDOW title [minrows [mincols]] ['NO-DISPLAY])
  40.  
  41. (define (new-window title . rest)
  42.   (let ((minrows (or (number? (car rest)) 0))
  43.         (mincols (or (number? (cadr rest)) 0))
  44.         (no-display (memq 'no-display rest)))
  45.     (call/cc
  46.       (lambda (exit)
  47.         (letrec ((ulc (integer->char 218))
  48.                  (rlc (integer->char 217))
  49.                  (left #\K)
  50.                  (up #\H)
  51.                  (right #\M)
  52.                  (down #\P)
  53.                  (accept #\return) 
  54.                  (hold '())
  55.                  (cursor 
  56.                    (let ((w (make-window "" #F)))
  57.                      (window-set-size! w 1 1)
  58.              (window-reverse-text! w)
  59.                      w))
  60.                  (read-char-1
  61.                    (lambda ()
  62.                      (let ((char (read-char cursor)))
  63.                        (if (char=? char (integer->char 0)) 
  64.                            (read-char cursor) char))))
  65.                  (mark-corner
  66.                    (lambda (uly ulx lry lrx ch)   ;note y,x means row,col
  67.                      (let loop ((r uly)
  68.                                 (c ulx))
  69.                        (window-set-position! cursor r c)
  70.                        (window-popup cursor)
  71.                        (display ch cursor)
  72.                        (window-set-cursor! cursor 0 0)
  73.                        (let ((char (read-char-1)))
  74.                          (window-popup-delete cursor)
  75.                          (cond ((eqv? char left)  
  76.                                 (loop r (if (>= (-1+ c) ulx) (-1+ c) c)))
  77.                                ((eqv? char up)
  78.                                 (loop (if (>= (-1+ r) uly) (-1+ r) r) c))
  79.                                ((eqv? char right) 
  80.                                 (loop r (if (< (1+ c) lrx) (1+ c) c)))
  81.                                ((eqv? char down) 
  82.                                 (loop (if (< (1+ r) lry) (1+ r) r) c))
  83.                                ((eqv? char accept) 
  84.                                 (window-set-cursor! cursor 0 0)
  85.                                 (set! hold
  86.                                       (list (window-save-contents cursor) r c))
  87.                                 (display ch cursor)
  88.                                 (cons r c))
  89.                                (else
  90.                                 (and hold 
  91.                                      (let ((char (car hold))
  92.                                            (r (cadr hold))
  93.                                            (c (caddr hold)))
  94.                                        (window-set-position! cursor r c)
  95.                                        (window-restore-contents cursor char)))
  96.                                 (exit #F))))))))
  97.           (let* ((uly (car (window-get-position (current-output-port))))
  98.                  (ulx (cdr (window-get-position (current-output-port))))
  99.                  (lry (+ uly (car (window-get-size (current-output-port)))))
  100.                  (lrx (+ ulx (cdr (window-get-size (current-output-port)))))
  101.                  (ulc-position (mark-corner uly ulx 
  102.                                             (- lry minrows) (- lrx mincols)
  103.                                             ulc))
  104.                  (new-uly (car ulc-position))
  105.                  (new-ulx (cdr ulc-position))
  106.                  (rlc-position (mark-corner (+ new-uly minrows) 
  107.                                             (+ new-ulx mincols) lry lrx rlc))
  108.                  (new-lry (car rlc-position))
  109.                  (new-lrx (cdr rlc-position))
  110.                  (new-width (1+ (- new-lrx new-ulx)))
  111.                  (new-height (1+ (- new-lry new-uly)))
  112.                  (w (make-window title #T)))
  113.             (window-set-position! w new-uly new-ulx)
  114.             (window-set-size! w new-height new-width)
  115.             (or no-display (window-clear w))
  116.             w))))))
  117.